home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / clean / sun3.lha / Sun3 / deltaMira.abc < prev    next >
Text File  |  1992-08-07  |  4KB  |  239 lines
  1. .comp 800 111111011
  2. .code     141       4      15
  3. .start _nostart_
  4. .endinfo
  5. .implab _cycle_in_spine
  6. .implab _reserve
  7. .implab _type_error
  8. .impdesc _Defer
  9. .implab _defer_code
  10. .implab _hnf
  11. .impdesc _Cons
  12. .impdesc _Tuple
  13. .impdesc _Select
  14. .impdesc _Nil
  15. .implab _driver
  16. .implab e_system_nAP
  17. .implab e_system_sAP
  18. .impdesc e_system_AP
  19. .desc m_deltaMira _hnf _hnf 0 "deltaMira"
  20.  
  21. .export e_deltaMira_EQUAL
  22. .export e_deltaMira_sEQUAL
  23. .export e_deltaMira_nEQUAL
  24. .desc e_deltaMira_EQUAL e_deltaMira_nEQUAL e_deltaMira_lEQUAL 2 "EQUAL"
  25. .o 2 0
  26. e_deltaMira_lEQUAL:
  27.     repl_args 1 1
  28. .d 2 0
  29.     jsr eaEQUAL
  30. .o 0 1 b
  31.     create
  32.     fillB_b 0 0
  33.     pop_b 1
  34. .d 1 0
  35.     rtn
  36. .n 2 e_deltaMira_EQUAL
  37. .o 1 0
  38. e_deltaMira_nEQUAL:
  39.     push_node _reserve 2
  40. .d 2 0
  41.     jsr eaEQUAL
  42. .o 0 1 b
  43.     getWL 0
  44.     fillB_b 0 0
  45.     release
  46.     pop_b 1
  47. .d 1 0
  48.     rtn
  49. .o 2 0
  50. eaEQUAL:
  51.             ||    y
  52.     push_a 1
  53.     jsr_eval
  54.     pop_a 1
  55.             ||    x
  56.     jsr_eval
  57.             ||    y
  58.             ||    x
  59. .o 2 0
  60. e_deltaMira_sEQUAL:
  61. .o 2 0
  62. sEQUAL.1:
  63.             ||    Match code for alternative 1, stacksizes A: 2 B: 0
  64.             ||    Building the contractum, Stacksizes A: 2 B: 0
  65. ==:    eq_symbol    0 1                    | compare the descriptors
  66.     jmp_false    ==exitFalse
  67.     get_node_arity    0                | push the node arity on bstack
  68.     push_b    0                        | and copy it (the argnumber)
  69. ==argumentevalloop:
  70.     eqI_b        0 0                    | check if all arguments are
  71.     jmp_true    ==compare            | evaluated. If so, start comparing.
  72.     push_b        1
  73.     push_b        1
  74.     push_arg_b    0                    | push a couple of arguments
  75.     jsr_eval                        | on top of the a-stack and
  76.     pop_a        1
  77.     push_b        1
  78.     push_b        1
  79.     push_arg_b    1                    | evaluate them.
  80.     jsr_eval            
  81.     pop_a        1
  82.     decI                            | decrease the argument number and
  83.     jmp            ==argumentevalloop    | evaluate the rest of the arguments.
  84. ==compare:
  85.     update_b    1 0                    | reset the argument number
  86. ==compareloop:
  87.     eqI_b        0 0                    | check if all arguments are
  88.     jmp_true        ==exitTrue        | compared. If so, exit to True.
  89.     push_b    1
  90.     push_b    1
  91.     push_arg_b    0                    | push a couple of arguments
  92.     push_b    1
  93.     push_b    1
  94.     push_arg_b    2                    | on the stack and
  95. .d 2 0
  96.     jsr ==                            | compare them.
  97. .o 0 1 b
  98.     jmp_false    ==exitFalse2
  99.     decI                            | decrease the argument number and
  100.     jmp            ==compareloop        | compare the rest of the arguments.
  101. ==exitFalse2:    
  102.     pop_b        2
  103. ==exitFalse:
  104.     pop_a        2
  105.     pushB        FALSE
  106. .d 0 1 b
  107.     rtn
  108. ==exitTrue:
  109.     pop_b        2
  110.     pop_a        2
  111.     pushB        TRUE
  112. .d 0 1 b
  113.     rtn
  114. .inline EQUAL
  115. .d 2 0
  116.     jsr            e_deltaMira_sEQUAL
  117. .o 0 1 b
  118. .end
  119. .d 0 1 b
  120.     rtn
  121. .export e_deltaMira_NOTEQUAL
  122. .export e_deltaMira_sNOTEQUAL
  123. .export e_deltaMira_nNOTEQUAL
  124. .desc e_deltaMira_NOTEQUAL e_deltaMira_nNOTEQUAL e_deltaMira_lNOTEQUAL 2 "NOTEQUAL"
  125. .o 2 0
  126. e_deltaMira_lNOTEQUAL:
  127.     repl_args 1 1
  128. .d 2 0
  129.     jsr eaNOTEQUAL
  130. .o 0 1 b
  131.     create
  132.     fillB_b 0 0
  133.     pop_b 1
  134. .d 1 0
  135.     rtn
  136. .n 2 e_deltaMira_NOTEQUAL
  137. .o 1 0
  138. e_deltaMira_nNOTEQUAL:
  139.     push_node _reserve 2
  140. .d 2 0
  141.     jsr eaNOTEQUAL
  142. .o 0 1 b
  143.     getWL 0
  144.     fillB_b 0 0
  145.     release
  146.     pop_b 1
  147. .d 1 0
  148.     rtn
  149. .o 2 0
  150. eaNOTEQUAL:
  151.             ||    y
  152.     push_a 1
  153.     jsr_eval
  154.     pop_a 1
  155.             ||    x
  156.     jsr_eval
  157.             ||    y
  158.             ||    x
  159. .o 2 0
  160. e_deltaMira_sNOTEQUAL:
  161. .o 2 0
  162. sNOTEQUAL.1:
  163.             ||    Match code for alternative 1, stacksizes A: 2 B: 0
  164.             ||    Building the contractum, Stacksizes A: 2 B: 0
  165. .d 2 0
  166.     jsr ==
  167. .o 0 1 b
  168.     notB
  169. .d 0 1 b
  170.     rtn
  171. .inline NOTEQUAL
  172. .d 2 0
  173.     jsr            e_deltaMira_sNOTEQUAL
  174. .o 0 1 b
  175. .end
  176. .d 0 1 b
  177.     rtn
  178. .export e_deltaMira_UNDRESS
  179. .export e_deltaMira_sUNDRESS
  180. .export e_deltaMira_nUNDRESS
  181. .desc e_deltaMira_UNDRESS e_deltaMira_nUNDRESS e_deltaMira_lUNDRESS 1 "UNDRESS"
  182. .o 2 0
  183. e_deltaMira_lUNDRESS:
  184.     update_a 1 0
  185.     create
  186.     update_a 0 2
  187.     pop_a 1
  188. .d 2 0
  189.     jmp eaUNDRESS
  190. .n 1 e_deltaMira_UNDRESS
  191. .o 1 0
  192. e_deltaMira_nUNDRESS:
  193.     push_node _reserve 1
  194. .o 2 0
  195. eaUNDRESS:
  196.             ||    x
  197.     jsr_eval
  198.             ||    x
  199. .o 2 0
  200. e_deltaMira_sUNDRESS:
  201. .o 2 0
  202. sUNDRESS.1:
  203.             ||    Match code for alternative 1, stacksizes A: 1 B: 0
  204.             ||    Building the contractum, Stacksizes A: 1 B: 0
  205.     get_node_arity    0                    | get the arity and
  206.     push_b            0                    | push the argument number
  207.     create                                | create and
  208.     fill             _Nil 0 _hnf 0        | fill the tail of the list
  209. UND_loop:
  210.     eqI_b            0 0                    | check if all args
  211.     jmp_true        UND_ready            | are handled
  212.     create
  213.     push_a            1
  214.     push_b            1
  215.     push_b            1
  216.     push_arg_b        3                    | create and fill
  217.     fill             _Cons 2 _hnf 2        | the next list element
  218.     update_a        0 1
  219.     pop_a            1
  220.     decI                                | decrease the argument number
  221.     jmp            UND_loop                | and continue with the other arguments
  222. UND_ready:
  223.     create                                | create and fill the head with
  224.     fillS_symbol    2 0                    | the string
  225.     getWL            3
  226.     fill            _Cons 2 _hnf 3        | and fill the last element (root!)
  227.     release
  228.     pop_a            1
  229.     pop_b            2
  230. .d 1 0
  231.     rtn
  232. .inline UNDRESS
  233. .d 2 0
  234.     jsr            e_deltaMira_sUNDRESS
  235. .o 1 0
  236. .end
  237. .d 1 0
  238.     rtn
  239.